Acorn User: China

home *** CD-ROM | disk | FTP | other *** search

/ Acorn User: China / Acorn User China CD-ROM (UK) (Disc B) / Acorn User China CD-ROM (UK) (Disc B).bin / STUTTGART / LANG / GOFER / !Gofer_preludes_simple < prev next >

Wrap

Text File | 1993-02-18 | 19.1 KB | 612 lines

-- __________ __________ __________ __________ ________ -- / _______/ / ____ / / _______/ / _______/ / ____ \ -- / / _____ / / / / / /______ / /______ / /___/ / -- / / /_ / / / / / / _______/ / _______/ / __ __/ -- / /___/ / / /___/ / / / / /______ / / \ \ -- /_________/ /_________/ /__/ /_________/ /__/ \__\ -- -- Functional programming environment, Version 2.28 -- Copyright Mark P Jones 1991-1993. -- -- Simplified prelude, without any type classes and overloaded values -- Based on the Haskell standard prelude version 1.2. -- -- This prelude file shows one approach to using Gofer without the -- use of overloaded implementations of show, <=, == etc. -- -- Needless to say, some (most) of the Gofer demonstration programs -- cannot be used in connection with this prelude ... but a wide -- family of programs can be used without needing to worry about -- type classes at all. -- help = "press :? for a list of commands" quit = help ++ ", :q to quit" -- Operator precedence table: --------------------------------------------- infixl 9 !! infixr 9 . infixr 8 ^ infixl 7 * infix 7 /, `div`, `quot`, `rem`, `mod` infixl 6 +, - infix 5 \\ infixr 5 ++, : infix 4 ==, /=, <, <=, >=, > infix 4 `elem`, `notElem` infixr 3 && infixr 2 || infixr 0 $ -- Standard combinators: -------------------------------------------------- primitive strict "primStrict" :: (a -> b) -> a -> b const :: a -> b -> a const k x = k id :: a -> a id x = x curry :: ((a,b) -> c) -> a -> b -> c curry f a b = f (a,b) uncurry :: (a -> b -> c) -> (a,b) -> c uncurry f (a,b) = f a b fst :: (a,b) -> a fst (x,_) = x snd :: (a,b) -> b snd (_,y) = y fst3 :: (a,b,c) -> a fst3 (x,_,_) = x snd3 :: (a,b,c) -> b snd3 (_,x,_) = x thd3 :: (a,b,c) -> c thd3 (_,_,x) = x (.) :: (b -> c) -> (a -> b) -> (a -> c) (f . g) x = f (g x) flip :: (a -> b -> c) -> b -> a -> c flip f x y = f y x ($) :: (a -> b) -> a -> b -- pronounced as `apply' elsewhere f $ x = f x -- Boolean functions: ----------------------------------------------------- (&&), (||) :: Bool -> Bool -> Bool False && x = False True && x = x False || x = x True || x = True not :: Bool -> Bool not True = False not False = True and, or :: [Bool] -> Bool and = foldr (&&) True or = foldr (||) False any, all :: (a -> Bool) -> [a] -> Bool any p = or . map p all p = and . map p otherwise :: Bool otherwise = True -- Essentials and builtin primitives: ------------------------------------ primitive (==) "primGenericEq", (/=) "primGenericNe", (<=) "primGenericLe", (<) "primGenericLt", (>=) "primGenericGe", (>) "primGenericGt" :: a -> a -> Bool max x y | x >= y = x | otherwise = y min x y | x <= y = x | otherwise = y enumFrom n = iterate (1+) n -- [n..] enumFromThen n m = iterate ((m-n)+) n -- [n,m..] enumFromTo n m = takeWhile (m>=) (enumFrom n) -- [n..m] enumFromThenTo n o m = takeWhile ((if o>=n then (>=) else (<=)) m) -- [n,o..m] (enumFromThen n o) primitive (+) "primPlusInt", (-) "primMinusInt", (/) "primDivInt", div "primDivInt", quot "primQuotInt", rem "primRemInt", mod "primModInt", (*) "primMulInt" :: Int -> Int -> Int primitive negate "primNegInt" :: Int -> Int primitive primPrint "primPrint" :: Int -> a -> String -> String show :: a -> String show x = primPrint 0 x [] -- Character functions: --------------------------------------------------- primitive ord "primCharToInt" :: Char -> Int primitive chr "primIntToChar" :: Int -> Char isAscii, isControl, isPrint, isSpace :: Char -> Bool isUpper, isLower, isAlpha, isDigit, isAlphanum :: Char -> Bool isAscii c = ord c < 128 isControl c = c < ' ' || c == '\DEL' isPrint c = c >= ' ' && c <= '~' isSpace c = c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f' || c == '\v' isUpper c = c >= 'A' && c <= 'Z' isLower c = c >= 'a' && c <= 'z' isAlpha c = isUpper c || isLower c isDigit c = c >= '0' && c <= '9' isAlphanum c = isAlpha c || isDigit c toUpper, toLower :: Char -> Char toUpper c | isLower c = chr (ord c - ord 'a' + ord 'A') | otherwise = c toLower c | isUpper c = chr (ord c - ord 'A' + ord 'a') | otherwise = c minChar, maxChar :: Char minChar = chr 0 maxChar = chr 255 -- Standard numerical functions: ----------------------------------------- subtract :: Int -> Int -> Int subtract = flip (-) even, odd :: Int -> Bool even x = x `rem` 2 == 0 odd = not . even gcd :: Int -> Int -> Int gcd x y = gcd' (abs x) (abs y) where gcd' x 0 = x gcd' x y = gcd' y (x `rem` y) lcm :: Int -> Int -> Int lcm _ 0 = 0 lcm 0 _ = 0 lcm x y = abs ((x `quot` gcd x y) * y) (^) :: Int -> Int -> Int x ^ 0 = 1 x ^ (n+1) = f x n x where f _ 0 y = y f x n y = g x n where g x n | even n = g (x*x) (n`quot`2) | otherwise = f x (n-1) (x*y) abs :: Int -> Int abs x | x >= 0 = x | x < 0 = - x signum :: Int -> Int signum x | x == 0 = 0 | x > 0 = 1 | x < 0 = -1 sum, product :: [Int] -> Int sum = foldl' (+) 0 product = foldl' (*) 1 sums, products :: [Int] -> [Int] sums = scanl (+) 0 products = scanl (*) 1 -- Standard list processing functions: ----------------------------------- head :: [a] -> a head (x:_) = x last :: [a] -> a last [x] = x last (_:xs) = last xs tail :: [a] -> [a] tail (_:xs) = xs init :: [a] -> [a] init [x] = [] init (x:xs) = x : init xs (++) :: [a] -> [a] -> [a] -- append lists. Associative with [] ++ ys = ys -- left and right identity []. (x:xs) ++ ys = x:(xs++ys) length :: [a] -> Int -- calculate length of list length = foldl' (\n _ -> n+1) 0 (!!) :: [a] -> Int -> a -- xs!!n selects the nth element of (x:_) !! 0 = x -- the list xs (first element xs!!0) (_:xs) !! (n+1) = xs !! n -- for any n < length xs. iterate :: (a -> a) -> a -> [a] -- generate the infinite list iterate f x = x : iterate f (f x) -- [x, f x, f (f x), ... repeat :: a -> [a] -- generate the infinite list repeat x = xs where xs = x:xs -- [x, x, x, x, ... cycle :: [a] -> [a] -- generate the infinite list cycle xs = xs' where xs'=xs++xs'-- xs ++ xs ++ xs ++ ... copy :: Int -> a -> [a] -- make list of n copies of x copy n x = take n xs where xs = x:xs nub :: [a] -> [a] -- remove duplicates from list nub [] = [] nub (x:xs) = x : nub (filter (x/=) xs) reverse :: [a] -> [a] -- reverse elements of list reverse = foldl (flip (:)) [] elem, notElem :: a -> [a] -> Bool elem = any . (==) -- test for membership in list notElem = all . (/=) -- test for non-membership maximum, minimum :: [a] -> a maximum = foldl1 max -- max element in non-empty list minimum = foldl1 min -- min element in non-empty list concat :: [[a]] -> [a] -- concatenate list of lists concat = foldr (++) [] transpose :: [[a]] -> [[a]] -- transpose list of lists transpose = foldr (\xs xss -> zipWith (:) xs (xss ++ repeat [])) [] -- null provides a simple and efficient way of determining whether a given -- list is empty, without using (==) and hence avoiding a constraint of the -- form Eq [a] in the full standard prelude. null :: [a] -> Bool null [] = True null (_:_) = False -- (\\) is used to remove the first occurrence of each element in the -- second list from the first list. It is a kind of inverse of (++) in -- the sense that (xs ++ ys) \\ xs = ys for any finite list xs of -- proper values xs. (\\) :: [a] -> [a] -> [a] (\\) = foldl del where [] `del` _ = [] (x:xs) `del` y | x == y = xs | otherwise = x : xs `del` y -- map f xs applies the function f to each element of the list xs returning -- the corresponding list of results. filter p xs returns the sublist of -- xs containing those elements which satisfy the predicate p. map :: (a -> b) -> [a] -> [b] map f [] = [] map f (x:xs) = f x : map f xs filter :: (a -> Bool) -> [a] -> [a] filter _ [] = [] filter p (x:xs) | p x = x : xs' | otherwise = xs' where xs' = filter p xs -- Fold primitives: The foldl and scanl functions, variants foldl1 and -- scanl1 for non-empty lists, and strict variants foldl' scanl' describe -- common patterns of recursion over lists. Informally: -- -- foldl f a [x1, x2, ..., xn] = f (...(f (f a x1) x2)...) xn -- = (...((a `f` x1) `f` x2)...) `f` xn -- etc... -- -- The functions foldr, scanr and variants foldr1, scanr1 are duals of -- these functions: -- e.g. foldr f a xs = foldl (flip f) a (reverse xs) for finite lists xs. foldl :: (a -> b -> a) -> a -> [b] -> a foldl f z [] = z foldl f z (x:xs) = foldl f (f z x) xs foldl1 :: (a -> a -> a) -> [a] -> a foldl1 f (x:xs) = foldl f x xs foldl' :: (a -> b -> a) -> a -> [b] -> a foldl' f a [] = a foldl' f a (x:xs) = strict (foldl' f) (f a x) xs scanl :: (a -> b -> a) -> a -> [b] -> [a] scanl f q xs = q : (case xs of [] -> [] x:xs -> scanl f (f q x) xs) scanl1 :: (a -> a -> a) -> [a] -> [a] scanl1 f (x:xs) = scanl f x xs scanl' :: (a -> b -> a) -> a -> [b] -> [a] scanl' f q xs = q : (case xs of [] -> [] x:xs -> strict (scanl' f) (f q x) xs) foldr :: (a -> b -> b) -> b -> [a] -> b foldr f z [] = z foldr f z (x:xs) = f x (foldr f z xs) foldr1 :: (a -> a -> a) -> [a] -> a foldr1 f [x] = x foldr1 f (x:xs) = f x (foldr1 f xs) scanr :: (a -> b -> b) -> b -> [a] -> [b] scanr f q0 [] = [q0] scanr f q0 (x:xs) = f x q : qs where qs@(q:_) = scanr f q0 xs scanr1 :: (a -> a -> a) -> [a] -> [a] scanr1 f [x] = [x] scanr1 f (x:xs) = f x q : qs where qs@(q:_) = scanr1 f xs -- List breaking functions: -- -- take n xs returns the first n elements of xs -- drop n xs returns the remaining elements of xs -- splitAt n xs = (take n xs, drop n xs) -- -- takeWhile p xs returns the longest initial segment of xs whose -- elements satisfy p -- dropWhile p xs returns the remaining portion of the list -- span p xs = (takeWhile p xs, dropWhile p xs) -- -- takeUntil p xs returns the list of elements upto and including the -- first element of xs which satisfies p take :: Int -> [a] -> [a] take 0 _ = [] take _ [] = [] take (n+1) (x:xs) = x : take n xs drop :: Int -> [a] -> [a] drop 0 xs = xs drop _ [] = [] drop (n+1) (_:xs) = drop n xs splitAt :: Int -> [a] -> ([a], [a]) splitAt 0 xs = ([],xs) splitAt _ [] = ([],[]) splitAt (n+1) (x:xs) = (x:xs',xs'') where (xs',xs'') = splitAt n xs takeWhile :: (a -> Bool) -> [a] -> [a] takeWhile p [] = [] takeWhile p (x:xs) | p x = x : takeWhile p xs | otherwise = [] takeUntil :: (a -> Bool) -> [a] -> [a] takeUntil p [] = [] takeUntil p (x:xs) | p x = [x] | otherwise = x : takeUntil p xs dropWhile :: (a -> Bool) -> [a] -> [a] dropWhile p [] = [] dropWhile p xs@(x:xs') | p x = dropWhile p xs' | otherwise = xs span, break :: (a -> Bool) -> [a] -> ([a],[a]) span p [] = ([],[]) span p xs@(x:xs') | p x = let (ys,zs) = span p xs' in (x:ys,zs) | otherwise = ([],xs) break p = span (not . p) -- Text processing: -- lines s returns the list of lines in the string s. -- words s returns the list of words in the string s. -- unlines ls joins the list of lines ls into a single string -- with lines separated by newline characters. -- unwords ws joins the list of words ws into a single string -- with words separated by spaces. lines :: String -> [String] lines "" = [] lines s = l : (if null s' then [] else lines (tail s')) where (l, s') = break ('\n'==) s words :: String -> [String] words s = case dropWhile isSpace s of "" -> [] s' -> w : words s'' where (w,s'') = break isSpace s' unlines :: [String] -> String unlines = concat . map (\l -> l ++ "\n") unwords :: [String] -> String unwords [] = [] unwords ws = foldr1 (\w s -> w ++ ' ':s) ws -- Merging and sorting lists: merge :: [a] -> [a] -> [a] merge [] ys = ys merge xs [] = xs merge (x:xs) (y:ys) | x <= y = x : merge xs (y:ys) | otherwise = y : merge (x:xs) ys sort :: [a] -> [a] sort = foldr insert [] insert :: a -> [a] -> [a] insert x [] = [x] insert x (y:ys) | x <= y = x:y:ys | otherwise = y:insert x ys qsort :: [a] -> [a] qsort [] = [] qsort (x:xs) = qsort [ u | u<-xs, u<x ] ++ [ x ] ++ qsort [ u | u<-xs, u>=x ] -- zip and zipWith families of functions: zip :: [a] -> [b] -> [(a,b)] zip = zipWith (\a b -> (a,b)) zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] zip3 = zipWith3 (\a b c -> (a,b,c)) zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] zip4 = zipWith4 (\a b c d -> (a,b,c,d)) zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] zip5 = zipWith5 (\a b c d e -> (a,b,c,d,e)) zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a,b,c,d,e,f)] zip6 = zipWith6 (\a b c d e f -> (a,b,c,d,e,f)) zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a,b,c,d,e,f,g)] zip7 = zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g)) zipWith :: (a->b->c) -> [a]->[b]->[c] zipWith z (a:as) (b:bs) = z a b : zipWith z as bs zipWith _ _ _ = [] zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith3 z (a:as) (b:bs) (c:cs) = z a b c : zipWith3 z as bs cs zipWith3 _ _ _ _ = [] zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4 z as bs cs ds zipWith4 _ _ _ _ _ = [] zipWith5 :: (a->b->c->d->e->f) -> [a]->[b]->[c]->[d]->[e]->[f] zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) = z a b c d e : zipWith5 z as bs cs ds es zipWith5 _ _ _ _ _ _ = [] zipWith6 :: (a->b->c->d->e->f->g) -> [a]->[b]->[c]->[d]->[e]->[f]->[g] zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) = z a b c d e f : zipWith6 z as bs cs ds es fs zipWith6 _ _ _ _ _ _ _ = [] zipWith7 :: (a->b->c->d->e->f->g->h) -> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h] zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) = z a b c d e f g : zipWith7 z as bs cs ds es fs gs zipWith7 _ _ _ _ _ _ _ _ = [] unzip :: [(a,b)] -> ([a],[b]) unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], []) -- Formatted output: ----------------------------------------------------- cjustify, ljustify, rjustify :: Int -> String -> String cjustify n s = space halfm ++ s ++ space (m - halfm) where m = n - length s halfm = m `div` 2 ljustify n s = s ++ space (n - length s) rjustify n s = space (n - length s) ++ s space :: Int -> String space n = copy n ' ' layn :: [String] -> String layn = lay 1 where lay _ [] = [] lay n (x:xs) = rjustify 4 (show n) ++ ") " ++ x ++ "\n" ++ lay (n+1) xs -- Miscellaneous: -------------------------------------------------------- until :: (a -> Bool) -> (a -> a) -> a -> a until p f x | p x = x | otherwise = until p f (f x) until' :: (a -> Bool) -> (a -> a) -> a -> [a] until' p f = takeUntil p . iterate f primitive error "primError" :: String -> a undefined :: a undefined | False = undefined asTypeOf :: a -> a -> a x `asTypeOf` _ = x -- I/O functions and definitions: ---------------------------------------- -- This is the minimum required for bootstrapping and execution of -- interactive programs. {- The Dialogue, Request, Response and IOError datatypes are now builtin: data Request = -- file system requests: ReadFile String | WriteFile String String | AppendFile String String -- channel system requests: | ReadChan String | AppendChan String String -- environment requests: | Echo Bool | GetArgs | GetProgName | GetEnv String data Response = Success | Str String | Failure IOError data IOError = WriteError String | ReadError String | SearchError String | FormatError String | OtherError String -- Continuation-based I/O: type Dialogue = [Response] -> [Request] -} run :: (String -> String) -> Dialogue run f ~(Success : ~(Str kbd : _)) = [Echo False, ReadChan "stdin", AppendChan "stdout" (f kbd)] primitive primFopen "primFopen" :: String -> a -> (String -> a) -> a openfile :: String -> String openfile f = primFopen f (error ("can't open file "++f)) id -- End of Gofer simplified prelude: ---------------------------------------